Excel - Módulo de Funções Utilitárias 1
ELetra : devolve true se o dado recebido for uma letra
Public Function ELetra(dado As String)
If Len(dado) > 1 Then
ELetra = False
Exit Function
End If
If dado >= "A" And dado <= "Z" Then
ELetra = True
Exit Function
End If
If dado >= "a" And dado <= "z" Then
ELetra = True
Exit Function
End If
ELetra = False
End Function
'retorna true se o dado é uma data válida - DD/MM/AA ou DD/MM/AAA
Public Function EData(dado As String) As Boolean
If IsDate(dado) Then
EData = True
Else
EData = False
End If
End Function
'retorna true se o dado é um cpf válido
'importante : Há cpfs antigos que não possuem o DV
'um cpf válido 038.277.936-37
Public Function ECPF(dado As String) As Boolean
Dim cpfLimpo As String 'cpf sem os .-/
Dim lMultiplicador As Integer
Dim lDv1 As Integer 'dv=digito verificador-1o digito
Dim lDv2 As Integer 'dv=digito verificador-2o digito
Dim lNumCPF As String
Dim i As Integer
lMultiplicador = 2
cpfLimpo = Limpa(dado) 'retirando separadores
If Len(cpfLimpo) = 8 Then
'cpfs antigos - sem DV
MsgBox ("Alguns CPFs antigos de 8 dígitos não tinham Digitos Verificadores")
ECPF = False
Exit Function
End If
If Len(cpfLimpo) > 11 Then
ECPF = False
Exit Function
End If
'Realiza o preenchimento dos zeros á esquerda - coloca zeros a esquerda do CPF até que complete 11 digitos
lNumCPF = String(11 - Len(cpfLimpo), "0") & cpfLimpo
'Realiza o cálculo do dividendo para o dv1 e o dv2
For i = 9 To 1 Step -1
lDv1 = (Mid(lNumCPF, i, 1) * lMultiplicador) + lDv1
lDv2 = (Mid(lNumCPF, i, 1) * (lMultiplicador + 1)) + lDv2
lMultiplicador = lMultiplicador + 1
Next
'Realiza o cálculo para chegar no primeiro dígito
lDv1 = lDv1 Mod 11
If lDv1 >= 2 Then
lDv1 = 11 - lDv1
Else
lDv1 = 0
End If
'Realiza o cálculo para chegar no segundo dígito
lDv2 = lDv2 + (lDv1 * 2)
lDv2 = lDv2 Mod 11
If lDv2 >= 2 Then
lDv2 = 11 - lDv2
Else
lDv2 = 0
End If
'Realiza a validação e retorna na função
If Right(lNumCPF, 2) = CStr(lDv1) & CStr(lDv2) Then
ECPF = True
Else
ECPF = False
End If
End Function
ECNPJ-Devolve true se o cnpj for válido
' Ex. CNPJ : 40.229.850/0001-80
Public Function ECNPJ(CNPJ As String) As Boolean
Dim VarDigito1 As Integer
Dim VarDigito2 As Integer
Dim VarDigito3 As Integer
Dim VarDigito4 As Integer
Dim VarDigito5 As Integer
Dim VarDigito6 As Integer
Dim VarDigito7 As Integer
Dim VarDigito8 As Integer
Dim VarDigito9 As Integer
Dim VarDigito10 As Integer
Dim VarDigito11 As Integer
Dim VarDigito12 As Integer
Dim VarDigito13 As Integer
Dim VarDigito14 As Integer
Dim VarCalcDigito1 As Integer
Dim VarCalcDigito2 As Integer
Dim VarUltDig As Integer
'Função adiciona o valor 0 à esquerda se não conter 14 dígitos.
If Len(CNPJ) < 14 Then
CNPJ = String(14 - Len(CNPJ), "0") & CNPJ
End If
CNPJ = Limpa(CNPJ) 'retirando separadores
'Variável recebe a posição do último dígito.
VarUltDig = Len(CNPJ)
'Sai da função caso a célula esteja vazia
If CNPJ = Empty Then
ECNPJ = False
Exit Function
End If
'Variáveis recebe o valor correspondente a cada dígito.
VarDigito1 = CInt(Mid(CNPJ, VarUltDig - 13, 1))
VarDigito2 = CInt(Mid(CNPJ, VarUltDig - 12, 1))
VarDigito3 = CInt(Mid(CNPJ, VarUltDig - 11, 1))
VarDigito4 = CInt(Mid(CNPJ, VarUltDig - 10, 1))
VarDigito5 = CInt(Mid(CNPJ, VarUltDig - 9, 1))
VarDigito6 = CInt(Mid(CNPJ, VarUltDig - 8, 1))
VarDigito7 = CInt(Mid(CNPJ, VarUltDig - 7, 1))
VarDigito8 = CInt(Mid(CNPJ, VarUltDig - 6, 1))
VarDigito9 = CInt(Mid(CNPJ, VarUltDig - 5, 1))
VarDigito10 = CInt(Mid(CNPJ, VarUltDig - 4, 1))
VarDigito11 = CInt(Mid(CNPJ, VarUltDig - 3, 1))
VarDigito12 = CInt(Mid(CNPJ, VarUltDig - 2, 1))
VarDigito13 = CInt(Mid(CNPJ, VarUltDig - 1, 1))
VarDigito14 = CInt(Mid(CNPJ, VarUltDig, 1))
'Cálculo do Primeiro Dígito.
VarCalcDigito1 = (VarDigito1 * 6) + (VarDigito2 * 7) + (VarDigito3 * 8) + (VarDigito4 * 9) + _
(VarDigito5 * 2) + (VarDigito6 * 3) + (VarDigito7 * 4) + (VarDigito8 * 5) + (VarDigito9 * 6) + _
(VarDigito10 * 7) + (VarDigito11 * 8) + (VarDigito12 * 9)
VarCalcDigito1 = VarCalcDigito1 Mod 11 'Cálculo do Resto.
'se o resto for igual a 10 recebe o valor 0
If VarCalcDigito1 = 10 Then
VarCalcDigito1 = 0
End If
'Cálculo do Segundo Dígito.
VarCalcDigito2 = (VarDigito1 * 5) + (VarDigito2 * 6) + (VarDigito3 * 7) + (VarDigito4 * 8) + _
(VarDigito5 * 9) + (VarDigito6 * 2) + (VarDigito7 * 3) + (VarDigito8 * 4) + (VarDigito9 * 5) + _
(VarDigito10 * 6) + (VarDigito11 * 7) + (VarDigito12 * 8) + (VarCalcDigito1 * 9)
VarCalcDigito2 = VarCalcDigito2 Mod 11 'Cálculo do Resto.
'se o resto for igual a 10 recebe o valor 0
If VarCalcDigito2 = 10 Then
VarCalcDigito2 = 0
End If
'Fazendo a validação dos dados calculado x informado
If VarDigito13 = VarCalcDigito1 And VarDigito14 = VarCalcDigito2 Then
ECNPJ = True
Else
ECNPJ = False
End If
End Function
Limpa-Retira separadores dos campos cpf, cjpj, etc
'retira separadores dos campos cpf, cjpj, etc...
Public Function Limpa(dado As String) As String
Dim a As String
a = dado
a = Replace(a, ".", "")
a = Replace(a, "/", "")
a = Replace(a, "-", "")
a = Replace(a, " ", "")
a = Replace(a, ":", "")
a = Replace(a, ";", "")
a = Replace(a, "_", "")
a = Replace(a, "*", "")
a = Replace(a, "&", "")
a = Replace(a, "%", "")
a = Replace(a, "$", "")
a = Replace(a, "#", "")
a = Replace(a, "@", "")
a = Replace(a, "!", "")
Limpa = a
End Function
ENumero : devolve true se o dado recebido for numérico apenas
Public Function ENumero(dado As String)
If IsNumeric(dado) Then
ENumero = True
Exit Function
End If
ENumero = False
End Function
ConverteFMTExcelUsu-Formatação do Nome de coluna para o Excel
'Converte formato celula Excel ($D$4) para usuario (D4)
Public Function ConverteFMTExcelUsu(Celula As String) As String
Dim a As String
a = Celula
a = Replace(a, "$", "")
ConverteFMTExcelUsu = a
End Function
RetornaCelulaCorrente-Função que retorna a célula ativa no formato padrão do Excel - EX: A1
Public Function RetornaCelulaCorrente() As String
RetornaCelulaCorrente = ConverteFMTExcelUsu(ActiveCell.Address)
End Function
RetornaLinhaCorrente-Função que retorna a linha que esta selecionada na planilha
'O valor retornado é numérico de 1 a n
Public Function RetornaLinhaCorrente() As Long
RetornaLinhaCorrente = ActiveCell.Row
End Function
'esta função converte 1 para A, 2 para B-A coluna do Excel de numérica para string
'se coluna > 26 começa AA...e assim por diante
Public Function ConverteColunaNumParaLetra(col As Integer) As String
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(col / 27)
iRemainder = col - (iAlpha * 27)
If iAlpha > 0 Then
ConverteColunaNumParaLetra = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConverteColunaNumParaLetra = ConverteColunaNumParaLetra & Chr(iRemainder + 64)
End If
End Function
RetornaColunaCorrente-Função que retorna a coluna que esta selecionada na planilha
' o valor retornado é numérico de 1 a n mas as colunas no Excel são de A a zzz
Public Function RetornaColunaCorrente() As String
Dim a As Integer
a = ActiveCell.Column
RetornaColunaCorrente = ConverteColunaNumParaLetra(a)
End Function
Ativando a Célula Corrente
'Algumas vezes o cursor esta numa célula mas o Excel não hachura suas bordas dificultando a
visualização de qual célula esta selecionada. Isto ocorre, por exemplo, quando eliminamos uma linha.
'esta função hachura a borda da célula que esta selecionada atualmente
Public Function ExibirCelulaCorrente()
ActiveCell.Activate
End Function
moveRelativo - Move o cursor em relação a sua posição atual
'uso : moveRelativo deslx, desly
' onde deslx é o número de células na posição x
' onde desly é o número de células na posição y
' se o deslocamento for positivo move para baixo e a direita
' se o deslocamento for negativo move para cima e para a esquerda
' o formato é $Col$Lin
Public Sub moverCelulaRelativa(desx As String, desy As String)
Dim col As Integer
Dim lin As Integer
Dim col2 As Integer
Dim lin2 As Integer
Dim deslx As Integer
Dim desly As Integer
'verificando o que foi digitado e convertendo para a função
If desx = "" And desy = "" Then Exit Sub 'não há deslocamento
If desx = "" Then
deslx = 0 'deslocamento x =0
Else
deslx = CInt(desx)
End If
If desy = "" Then
desly = 0 'deslocamento y =0
Else
desly = CInt(desy)
End If
col = ActiveCell.Column ' Retorna o nº da linha
lin = ActiveCell.Row ' Retorna o nº da linha
col2 = col + deslx ' adiciona desl no nº da coluna
lin2 = lin + desly ' adiciona desl no nº da linha
Range("$" + ConverteColunaNumParaLetra(col2) + "$" + CStr(lin2)).Activate
End Sub
moveAbsoluta - Move o cursor para uma posição específica na planilha
'uso : moveAbsoluta col, lin
' o formato é $Col$Lin col é letra ou número lin é numérico
Public Sub moverCelulaAbsoluta(col As String, lin As String)
'verificando o que foi digitado e convertendo para a função
If col = "" Or lin = "" Then Exit Sub 'não foi definido um destino
If Not ELetra(col) Then
If ENumero(col) Then 'convertendo de número para letra
col = ConverteColunaNumParaLetra(CInt(col))
Else
Exit Sub ' a coluna informada não é uma letra
End If
End If
If Not ENumero(lin) Then Exit Sub ' a linha informada não é um número
Range("$" + col + "$" + CStr(lin)).Activate
End Sub
RetornarValorCelulaCorrente - Retorna o valor da célula corrente
Public Function RetornarValorCelulaCorrente() As String
RetornarValorCelulaCorrente = ActiveCell.Value
End Function
ProcurarPor-Esta rotina procurar por um dado dentro da planilha
' e se encontrado para o cursor nela - activecell
Public Function ProcurarPor(dado As String)
Dim col As Integer
Dim lin As Integer
Dim posini As String
Dim valor As String
posini = ActiveCell.Address
For col = 1 To 100 ' só as 100 primeiras colunas
For lin = 1 To 100 'só as 100 primeiras linhas
'col = "$" + ConverteColunaNumParaLetra(col) + "$" + CStr(lin)
moverCelulaAbsoluta CStr(col), CStr(lin)
valor = RetornarValorCelulaCorrente
'If valor <> "" Then
' MsgBox (valor)
'End If
If valor <> "" Then
If InStr(UCase(valor), UCase(dado)) > 0 Then 'encontrou instr(substr, str)
ExibirCelulaCorrente
Exit Function
End If
End If
Next
Next
Range(posini).Activate
End Function
CopiaCelula-Função que copia o que esta numa célula para outra célula da planilha
Public Function CopiaCelula(colOrig As Long, linOrig As Long, colDest As Long, linDest As Long)
Cells(linDest, colDest).Value = Cells(linOrig, colOrig).Value
End Function
Abre o web browser dentro do Excel e interage com ele enviando teclas e dados
Private Sub btnAbrirBrowser_Click()
'This will load a webpage in IE
Dim a As String
Dim i As Long
Dim URL As String
Dim IE As Object
Dim objElement As Object
Dim objCollection As Object
'Create InternetExplorer Object
Set IE = CreateObject("InternetExplorer.Application")
'Set IE.Visible = True to make IE visible, or False for IE to run in the background
IE.Visible = True
'Define URL
URL = txtURL.Text
'Navigate to URL
IE.Navigate URL
' Statusbar let's user know website is loading
Application.StatusBar = URL & " is loading. Please wait..."
' Wait while IE loading...
'IE ReadyState = 4 signifies the webpage has loaded (the first loop is set to avoid inadvertently skipping over the second loop)
Do While IE.ReadyState = 4: DoEvents: Loop 'Do While
Do Until IE.ReadyState = 4: DoEvents: Loop 'Do Until
'Webpage Loaded
Application.StatusBar = URL & " Loaded"
'Get Window ID for IE so we can set it as activate window
HWNDSrc = IE.HWND
'Set IE as Active Window
SetForegroundWindow HWNDSrc
'Find & Fill Out Input Box
n = 0
a = ""
For Each itm In IE.document.all
a = a + itm.innerHTML + vbCrLf
'If itm = "[object HTMLInputElement]" Then
'n = n + 1
' If n = 3 Then
' itm.Value = "orksheet"
' itm.Focus 'Activates the Input box (makes the cursor appear)
' Application.SendKeys "{w}", True 'Simulates a 'W' keystroke. True tells VBA to wait
' 'until keystroke has finished before proceeding, allowing
' 'javascript on page to run and filter the table
' GoTo endmacro
' End If
'End If
Next
MsgBox (a)
endmacro:
'Unload IE
Set IE = Nothing
Set objElement = Nothing
Set objCollection = Nothing
'Dim a As String
'Set IE = CreateObject("InternetExplorer.Application")
'IE.Visible = True
'IE.Navigate txtURL.Text
' Loop de espera até o IE carregar a página
'Do While IE.Busy
' WScript.Sleep 100
'Loop
'a = IE.Document.all.Text
'MsgBox (IE)
' Preenche os campos necessários
'IE.Document.all.Item("username").Value = "username"
'IE.Document.All.Item("password").Value = "password"
' Invoca a função clique do botão de salvar
'IE.Document.All.Item(".salve").Click
'IE.Document.frames(0).Document.all("username").innertext = "username"
'IE.Document.frames(0).Document.all("senha").innertext = "senha"
End Sub